module cubed_sphere_parallel_mod

  use mpi
  use cubed_sphere_halo_mod
  use cubed_sphere_array_mod
  use cubed_sphere_objects

  implicit none

  private

  public fill_halo
  public global_min
  public global_max
  public global_sum

  interface global_min
    module procedure global_min_0d_r4
    module procedure global_min_0d_r8
    module procedure global_min_3d_r4
    module procedure global_min_3d_r8
  end interface global_min

  interface global_max
    module procedure global_max_0d_r4
    module procedure global_max_0d_r8
    module procedure global_max_3d_r4
    module procedure global_max_3d_r8
  end interface global_max

  interface global_sum
    module procedure global_sum_0d_r8
  end interface global_sum

contains

  subroutine fill_halo(array)

    type(cubed_sphere_array_type), intent(inout) :: array

    integer idom, io, iv

    do idom = 1, 6
      if (array%domain(idom)%active) then
        ! Send data.
        do io = 1, 8
          do iv = 1, array%var_stack%size
            call send_halo(array, array%domain(idom), array%var_stack%var_info(iv), array%domain(idom)%halo(io))
          end do
        end do
        ! Recv data.
        do io = 1, 8
          do iv = 1, array%var_stack%size
            call recv_halo(array, array%domain(idom), array%var_stack%var_info(iv), array%domain(idom)%halo(io))
          end do
        end do
      end if
    end do

  end subroutine fill_halo

  subroutine send_halo(array, darray, var_info, halo)

    type(cubed_sphere_array_type), intent(inout) :: array
    type(cubed_sphere_domain_array_type), intent(inout) :: darray
    type(var_info_type), intent(in) :: var_info
    type(cubed_sphere_halo_type), intent(in) :: halo

    integer i, ierr

    if (.not. var_info%fill_halo .or. halo%type == null_halo) return

    i = var_info%array_idx

    select case (var_info%loc)
    case ('C')
      select case (var_info%dtype)
      case (dtype_r8)
        if (var_info%only_2d) then
          call MPI_SEND(darray%a_2d_c_h_r8(:,:,i), 1, halo%send_type_2d(var_info%dtype), halo%proc_id, 1, &
                        proc%comm, ierr)
        else
          call MPI_SEND(darray%a_3d_c_h_r8(:,:,:,i), 1, halo%send_type_3d(var_info%dtype), halo%proc_id, 1, &
                        proc%comm, ierr)
        end if
      case (dtype_l)
        if (var_info%only_2d) then
          call MPI_SEND(darray%a_2d_c_h_l(:,:,i), 1, halo%send_type_2d(var_info%dtype), halo%proc_id, 1, &
                        proc%comm, ierr)
        else
          call MPI_SEND(darray%a_3d_c_h_l(:,:,:,i), 1, halo%send_type_3d(var_info%dtype), halo%proc_id, 1, &
                        proc%comm, ierr)
        end if
      end select
    case ('CA')
      if (var_info%only_2d) then
        call MPI_SEND(darray%a_2d_ca_h_r8(:,:,i), 1, halo%send_type_2d(var_info%dtype), halo%proc_id, 1, &
                      proc%comm, ierr)
      else
        call MPI_SEND(darray%a_3d_ca_h_r8(:,:,:,i), 1, halo%send_type_3d(var_info%dtype), halo%proc_id, 1, &
                      proc%comm, ierr)
      end if
    case default
      stop 'Not support halo filling except for cell arrays!'
    end select

  end subroutine send_halo

  subroutine recv_halo(array, darray_in, var_info, halo)

    type(cubed_sphere_array_type), intent(inout), target :: array
    type(cubed_sphere_domain_array_type), intent(inout), target :: darray_in
    type(var_info_type), intent(in) :: var_info
    type(cubed_sphere_halo_type), intent(in) :: halo

    type(cubed_sphere_domain_array_type), pointer :: darray
    integer i, ierr

    if (.not. var_info%fill_halo .or. halo%type == null_halo) return

    i = var_info%array_idx
    if (halo%type == inner_halo) then
      darray => darray_in
    else
      darray => array%domain(halo%idom)
    end if

    select case (var_info%loc)
    case ('C')
      select case (var_info%dtype)
      case (dtype_r8)
        if (var_info%only_2d) then
          call MPI_RECV(darray%a_2d_c_h_r8(:,:,i), 1, halo%recv_type_2d(var_info%dtype), halo%proc_id, 1, &
                        proc%comm, MPI_STATUS_IGNORE, ierr)
        else
          call MPI_RECV(darray%a_3d_c_h_r8(:,:,:,i), 1, halo%recv_type_3d(var_info%dtype), halo%proc_id, 1, &
                        proc%comm, MPI_STATUS_IGNORE, ierr)
        end if
      case (dtype_l)
        if (var_info%only_2d) then
          call MPI_RECV(darray%a_2d_c_h_l(:,:,i), 1, halo%recv_type_2d(var_info%dtype), halo%proc_id, 1, &
                        proc%comm, MPI_STATUS_IGNORE, ierr)
        else
          call MPI_RECV(darray%a_3d_c_h_l(:,:,:,i), 1, halo%recv_type_3d(var_info%dtype), halo%proc_id, 1, &
                        proc%comm, MPI_STATUS_IGNORE, ierr)
        end if
      end select
    case ('CA')
      if (var_info%only_2d) then
        call MPI_RECV(darray%a_2d_ca_h_r8(:,:,i), 1, halo%recv_type_2d(var_info%dtype), halo%proc_id, 1, &
                      proc%comm, MPI_STATUS_IGNORE, ierr)
      else
        call MPI_RECV(darray%a_3d_ca_h_r8(:,:,:,i), 1, halo%recv_type_3d(var_info%dtype), halo%proc_id, 1, &
                      proc%comm, MPI_STATUS_IGNORE, ierr)
      end if
    case default
      stop 'Not support halo filling except for cell arrays!'
    end select

  end subroutine recv_halo

  real(4) function global_min_0d_r4(x) result(res)

    real(4), intent(in) :: x

    integer ierr

    call MPI_ALLREDUCE(x, res, 1, MPI_DOUBLE, MPI_MIN, proc%comm, ierr)

  end function global_min_0d_r4

  real(8) function global_min_0d_r8(x) result(res)

    real(8), intent(in) :: x

    integer ierr

    call MPI_ALLREDUCE(x, res, 1, MPI_DOUBLE, MPI_MIN, proc%comm, ierr)

  end function global_min_0d_r8

  real(4) function global_min_3d_r4(x) result(res)

    real(4), intent(in) :: x(:,:,:)

    integer ierr

    call MPI_ALLREDUCE(minval(x), res, 1, MPI_REAL, MPI_MIN, proc%comm, ierr)

  end function global_min_3d_r4

  real(8) function global_min_3d_r8(x) result(res)

    real(8), intent(in) :: x(:,:,:)

    integer ierr

    call MPI_ALLREDUCE(minval(x), res, 1, MPI_DOUBLE, MPI_MIN, proc%comm, ierr)

  end function global_min_3d_r8

  real(4) function global_max_0d_r4(x) result(res)

    real(4), intent(in) :: x

    integer ierr

    call MPI_ALLREDUCE(x, res, 1, MPI_DOUBLE, MPI_MAX, proc%comm, ierr)

  end function global_max_0d_r4

  real(8) function global_max_0d_r8(x) result(res)

    real(8), intent(in) :: x

    integer ierr

    call MPI_ALLREDUCE(x, res, 1, MPI_DOUBLE, MPI_MAX, proc%comm, ierr)

  end function global_max_0d_r8

  real(4) function global_max_3d_r4(x) result(res)

    real(4), intent(in) :: x(:,:,:)

    integer ierr

    call MPI_ALLREDUCE(maxval(x), res, 1, MPI_REAL, MPI_MAX, proc%comm, ierr)

  end function global_max_3d_r4

  real(8) function global_max_3d_r8(x) result(res)

    real(8), intent(in) :: x(:,:,:)

    integer ierr

    call MPI_ALLREDUCE(maxval(x), res, 1, MPI_DOUBLE, MPI_MAX, proc%comm, ierr)

  end function global_max_3d_r8

  real(8) function global_sum_0d_r8(x) result(res)

    real(8), intent(in) :: x

    integer ierr

    call MPI_ALLREDUCE(x, res, 1, MPI_DOUBLE, MPI_SUM, proc%comm, ierr)

  end function global_sum_0d_r8

end module cubed_sphere_parallel_mod
